{*
  Object Pascal encryption routines
  @Author  Maciej Zagozda (1998-2008)
  @Licence Microsoft Reciprocal License (Ms-RL)
  @Website http://www.codeplex.com/intelitechdelphirtns/
  @Version 2008/04/20 Added documentation support
}

unit EncryptionRoutines;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Classes;

type
  TWordTriple = Array[0..2] of Word;
  TMD5Digest = Array [0..3] of LongWord;


function FileEncrypt(InFile, OutFile: String; Key: TWordTriple): boolean;
function FileDecrypt(InFile, OutFile: String; Key: TWordTriple): boolean;
function TextEncrypt(const s: string; Key: TWordTriple): string;
function TextDecrypt(const s: string; Key: TWordTriple): string;
function MemoryEncrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;
function MemoryDecrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;
function SimpleEncryptString(AStr: String): String;
function SimpleDecryptString(AStr: String): String;

implementation

uses
  IntegerRoutines;

function MemoryEncrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;
var
  pIn, pOut: ^byte;
  i : Cardinal;
begin
  if SrcSize = TargetSize then
  begin
    pIn := Src;
    pOut := Target;
    for i := 1 to SrcSize do
    begin
      pOut^ := pIn^ xor (Key[2] shr 8);
      Key[2] := Byte(pIn^ + Key[2]) * Key[0] + Key[1];
      inc(pIn);
      inc(pOut);
    end;
    Result := True;
  end else
    Result := False;
end;

function MemoryDecrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;
var
  pIn, pOut: ^byte;
  i : Cardinal;
begin
  if SrcSize = TargetSize then
  begin
    pIn := Src;
    pOut := Target;
    for i := 1 to SrcSize do
    begin
      pOut^ := pIn^ xor (Key[2] shr 8);
      Key[2] := byte(pOut^ + Key[2]) * Key[0] + Key[1];
      inc(pIn);
      inc(pOut);
    end;
    Result := True;
  end else
    Result := False;
end;

function TextCrypt(const s: string; Key: TWordTriple; Encrypt: Boolean): string;
var
  bOK: Boolean;
begin
  SetLength(Result, Length(s));
  if Encrypt then
    bOK := MemoryEncrypt(PChar(s), Length(s), PChar(Result), Length(Result), Key)
  else
    bOK := MemoryDecrypt(PChar(s), Length(s), PChar(Result), Length(Result), Key);
  if not bOK then Result := '';
end;

function FileCrypt(InFile, OutFile: String; Key: TWordTriple; Encrypt: Boolean): boolean;
var
  MIn, MOut: TMemoryStream;
begin
  MIn := TMemoryStream.Create;
  MOut := TMemoryStream.Create;
  Try
    MIn.LoadFromFile(InFile);
    MOut.SetSize(MIn.Size);
    if Encrypt then
      Result := MemoryEncrypt(MIn.Memory, MIn.Size, MOut.Memory, MOut.Size, Key)
    else
      Result := MemoryDecrypt(MIn.Memory, MIn.Size, MOut.Memory, MOut.Size, Key);
    MOut.SaveToFile(OutFile);
  finally
    MOut.Free;
    MIn.Free;
  end;
end;

function TextEncrypt(const s: string; Key: TWordTriple): string;
begin
  Result := TextCrypt(s, Key, True);
end;

function TextDecrypt(const s: string; Key: TWordTriple): string;
begin
  Result := TextCrypt(s, Key, False);
end;

function FileEncrypt(InFile, OutFile: String; Key: TWordTriple): boolean;
begin
  Result := FileCrypt(InFile, OutFile, Key, True);
end;

function FileDecrypt(InFile, OutFile: String; Key: TWordTriple): boolean;
begin
  Result := FileCrypt(InFile, OutFile, Key, False);
end;


{                                                                              }
{ CalcMD5                                                                      }
{                                                                              }
const
  MD5Table_1 : Array [0..15] of LongWord = (
      $D76AA478, $E8C7B756, $242070DB, $C1BDCEEE,
      $F57C0FAF, $4787C62A, $A8304613, $FD469501,
      $698098D8, $8B44F7AF, $FFFF5BB1, $895CD7BE,
      $6B901122, $FD987193, $A679438E, $49B40821);
  MD5Table_2 : Array [0..15] of LongWord = (
      $F61E2562, $C040B340, $265E5A51, $E9B6C7AA,
      $D62F105D, $02441453, $D8A1E681, $E7D3FBC8,
      $21E1CDE6, $C33707D6, $F4D50D87, $455A14ED,
      $A9E3E905, $FCEFA3F8, $676F02D9, $8D2A4C8A);
  MD5Table_3 : Array [0..15] of LongWord = (
      $FFFA3942, $8771F681, $6D9D6122, $FDE5380C,
      $A4BEEA44, $4BDECFA9, $F6BB4B60, $BEBFBC70,
      $289B7EC6, $EAA127FA, $D4EF3085, $04881D05,
      $D9D4D039, $E6DB99E5, $1FA27CF8, $C4AC5665);
  MD5Table_4 : Array [0..15] of LongWord = (
      $F4292244, $432AFF97, $AB9423A7, $FC93A039,
      $655B59C3, $8F0CCC92, $FFEFF47D, $85845DD1,
      $6FA87E4F, $FE2CE6E0, $A3014314, $4E0811A1,
      $F7537E82, $BD3AF235, $2AD7D2BB, $EB86D391);

{ Calculates new MD5 Digest (Array [0..3] of LongWord) given a Buffer          }
{$Q-}
Procedure TransformMD5Buffer (var Digest : TMD5Digest; const Buffer);
var A, B, C, D : LongWord;
    I          : Integer;
    J          : Byte;
    Buf        : Array [0..15] of LongWord absolute Buffer;
  Begin
    A := Digest [0];
    B := Digest [1];
    C := Digest [2];
    D := Digest [3];

    For I := 0 to 3 do
      begin
        J := I * 4;
        Inc (A, Buf [J]     + MD5Table_1 [J]     + (D xor (B and (C xor D)))); A := A shl  7 or A shr 25 + B;
        Inc (D, Buf [J + 1] + MD5Table_1 [J + 1] + (C xor (A and (B xor C)))); D := D shl 12 or D shr 20 + A;
        Inc (C, Buf [J + 2] + MD5Table_1 [J + 2] + (B xor (D and (A xor B)))); C := C shl 17 or C shr 15 + D;
        Inc (B, Buf [J + 3] + MD5Table_1 [J + 3] + (A xor (C and (D xor A)))); B := B shl 22 or B shr 10 + C;
      end;

    For I := 0 to 3 do
      begin
        J := I * 4;
        Inc (A, Buf [J + 1]           + MD5Table_2 [J]     + (C xor (D and (B xor C)))); A := A shl  5 or A shr 27 + B;
        Inc (D, Buf [(J + 6) mod 16]  + MD5Table_2 [J + 1] + (B xor (C and (A xor B)))); D := D shl  9 or D shr 23 + A;
        Inc (C, Buf [(J + 11) mod 16] + MD5Table_2 [J + 2] + (A xor (B and (D xor A)))); C := C shl 14 or C shr 18 + D;
        Inc (B, Buf [J]               + MD5Table_2 [J + 3] + (D xor (A and (C xor D)))); B := B shl 20 or B shr 12 + C;
      end;

    For I := 0 to 3 do
      begin
        J := 16 - (I * 4);
        Inc (A, Buf [(J + 5) mod 16]  + MD5Table_3 [16 - J]     + (B xor C xor D)); A := A shl  4 or A shr 28 + B;
        Inc (D, Buf [(J + 8) mod 16]  + MD5Table_3 [16 - J + 1] + (A xor B xor C)); D := D shl 11 or D shr 21 + A;
        Inc (C, Buf [(J + 11) mod 16] + MD5Table_3 [16 - J + 2] + (D xor A xor B)); C := C shl 16 or C shr 16 + D;
        Inc (B, Buf [(J + 14) mod 16] + MD5Table_3 [16 - J + 3] + (C xor D xor A)); B := B shl 23 or B shr  9 + C;
      end;

    For I := 0 to 3 do
      begin
        J := 16 - (I * 4);
        Inc (A, Buf [J mod 16]        + MD5Table_4 [16 - J]     + (C xor (B or not D))); A := A shl  6 or A shr 26 + B;
        Inc (D, Buf [(J + 7) mod 16]  + MD5Table_4 [16 - J + 1] + (B xor (A or not C))); D := D shl 10 or D shr 22 + A;
        Inc (C, Buf [(J + 14) mod 16] + MD5Table_4 [16 - J + 2] + (A xor (D or not B))); C := C shl 15 or C shr 17 + D;
        Inc (B, Buf [(J + 5) mod 16]  + MD5Table_4 [16 - J + 3] + (D xor (C or not A))); B := B shl 21 or B shr 11 + C;
      end;

    Inc (Digest [0], A);
    Inc (Digest [1], B);
    Inc (Digest [2], C);
    Inc (Digest [3], D);
  End;
{$IFDEF DEBUG}{$Q+}{$ENDIF}

Function MD5InitDigest : TMD5Digest;
  Begin
    Result [0] := $67452301;        // fixed initialization key
    Result [1] := $EFCDAB89;
    Result [2] := $98BADCFE;
    Result [3] := $10325476;
  End;

{
Function CalcMD5 (const Data : String) : TMD5Digest;
var S : String;
    I : Integer;
  Begin
    Result := MD5InitDigest;
    if Data = '' then
      exit;

    I := 1;
    While I + 63 <= Length (Data) do
      begin
        TransformMD5Buffer (Result, S [I]);
        Inc (I, 64);
      end;
    S := CopyFrom (Data, I) + #$80;
    if Length (S) > 64 - Sizeof (Int64) then
      begin
        S := PadRight (S, #0, 64);
        TransformMD5Buffer (Result, S [1]);
        S := '';
      end;
    S := PadRight (S, #0, 64 - Sizeof (Int64));
    S := S + Pack (Int64 (Length (Data) * 8));
    TransformMD5Buffer (Result, S [1]);
  End;
}
Function MD5DigestAsString (const L : TMD5Digest) : String;
  Begin
    SetLength (Result, Sizeof (L));
    Move (L [0], Result [1], Sizeof (L));
  End;

Function MD5DigestAsHexString (const L : TMD5Digest) : String;
type Buf = Array [0..15] of Byte;
     BufP = ^Buf;
var I : Integer;
    B : BufP;
  Begin
    Result := '';
    B := @L [0];
    For I := 0 to Length (L) * Sizeof (LongWord) - 1 do
      Result := Result + LowerCase (SysUtils.IntToHex (B [I], 2));
  End;

// (SS,27/1/04) encrypts a string using a simple method
// returns in hex format, can be used as a parameter
// when calling other application, because it only has
// 0123456789ABCDEF characters size will be twice as long
// as original string
// inverts each byte using XOR and reverses all characters
function SimpleEncryptString(AStr: String): String;
var
  i: Integer;
  s: String;
begin
  Result := '';
  for i := Length(AStr) downto 1 do         // go through each character backwards
  begin
    s := IntToHex(Ord(AStr[i]) xor $FF, 2); // convert to byte, invert and convert to decimal hex
    Result := Result + s[2] + s[1];         // add the two nibbles in reverse
  end;
end;

// (SS,27/1/04) opposite of SimpleEncryptString above
function SimpleDecryptString(AStr: String): String;
var
  i: Integer;
  s: String;
begin
  Result := '';
  for i := Length(AStr) div 2 downto 1 do
  begin
    s := AStr[i * 2] + AStr[i * 2 - 1];             // get the byte as hex with nibbles in reverse
    Result := Result + Chr(HexStrToInt(s) xor $FF)  // convert the hex string to integer invert and change to char and add to result
  end;
end;

end.


